

;
; Tools for dealing with the output of the vm-backtrace package
; This requires Scheme, so it does not run in the compiled VM.
;
; The VM that generated the data and the VM that is used to analyze it
; must be of the same version so the architecture information (arch.scm)
; is compatible.
;
; See backtrace.scm for the format of the data
;
; Usage (Method 1, in the VM run as Scheme)
;  - load debug-package.scm
;  - open the vm-backtrace package and insert the call to (trace-instruction) in (interpret)
;  - open this package
;  - use (get-backtrace) to get the current backtrace data from the running VM
;  - diasplay the data using the below functions

; Usage (Method 2, using the compiled VM)
;  - collect the backtrace data in the compiled VM (see backtrace.scm)
;  - start the VM as a Scheme program using start-vm.scm
;  - load debug-package.scm
;  - open this package
;  - load the collected data from the compiled VM into Scheme
;  - display the data using the below functions


; Disassemble a backtrace
; Shows the most recently executed instruction last
;
(define (disassemble-backtrace backtrace . maybe-limit)
  (let ((limit (if (or (null? maybe-limit)
                       (< (vector-length backtrace) (car maybe-limit)))
                   (vector-length backtrace)
                   (car maybe-limit))))
    (do ((i (- limit 1) (- i 1)))
        ((< i 0))
      (let* ((code (get-code backtrace i))   
             (pc   (cdr (vector-ref backtrace i))))
         (write-instruction (vector->code-vector code) pc 0 #f)))))


; disassemble the entire code vector of a backtrace entry (not just one instruction)
;
(define (disassemble-backtrace-code backtrace index)
  (disassemble (vector->code-vector (get-code backtrace index))))


; If the VM is run in Scheme, use this to directly get the current backtrace data as a Scheme vector
;
(define (get-backtrace)
  (read                                                ; read from string port
    (make-string-input-port                            ; turn string into input port
      (call-with-string-output-port dump-backtrace)))) ; output backtrace to string
            

; Output a graph in the DOT language showing how the code-vectors in backtrace are called
;
(define (graph-backtrace-to-file backtrace file)
  (call-with-output-file (translate file)
    (lambda (port)
      (graph-backtrace backtrace port))))

(define (graph-backtrace backtrace port)
  (let ((code-table (make-code-table))
        (call-table (make-call-table)))
    (display "digraph Backtrace {\n" port)
    
    ; gather all code vectors and add them to the table
    ; (the order is from most-recent to oldest
    (do ((i (- (vector-length backtrace) 1) (- i 1))
         (id 0 (+ id 1)))
        ((< i 0))
      (let ((code (car (vector-ref backtrace i)))
            (name (string-append "cv" (number->string id)))
            (label (number->string i))) ; todo: get a descriptive name here (from debug info?)
        (if (and code (not (table-ref code-table code)))
          (begin
            (table-set! code-table code name)
            (display "  " port)
            (display name port)
            (display " [" port)
            (if (vector-eq? code (car (vector-ref backtrace 0)))
              (display "style=filled,color=red, " port)) ; this is the code we are in
            (display "label = \"" port)
            (display label port)
            (display "\"];\n" port)))))
                   
    ; look at all calls and count them
    (let loop ((i 0) (previous #f))
      (if (not (= i (vector-length backtrace)))
        (let* ((code   (or (car (vector-ref backtrace i)) previous))
               (pc     (cdr (vector-ref backtrace i)))
               (opcode (vector-ref code pc)))
          ;(if (and (call-instruction? opcode) previous)
          (if (and code previous
                (or (call-instruction? opcode)
                    (not (vector-eq? code previous)))) 
            (let* ((caller (table-ref code-table code))
                   (callee (table-ref code-table previous)) ; its all in reverse order
                   (key    (list opcode caller callee pc))
                   (entry  (table-ref call-table key)))
              (if entry
                (table-set! call-table key (+ entry 1))
                (table-set! call-table key 1))))
          (loop (+ i 1) code))))
    
    ; write the calls
    (newline port)
    (table-walk 
      (lambda (key count)                          
        (display "  " port)
        (display (cadr key) port) ; caller
        (display " -> " port)
        (display (caddr key) port)  ; callee
        (display " [" port)
        (if (memq (enumerand->name (car key) op) '(return values closed-values char->utf utf->char)) 
          (display "color=grey, fontcolor=grey, " port))
        (display "label = \"" port)
        (display (enumerand->name (car key) op) port) ; call
        (display "\\npc=" port)
        (display (cadddr key) port) ; pc
        (if (> count 1)
          (begin
            (display "\\n(" port)
            (display count port)
            (display "x)" port)))
        (display "\"];\n" port))
      call-table)
  
    (display "}\n" port))) 

; -----------------------------------------------------------------------------

(define (vector->code-vector v)
  (let* ((l (vector-length v))   
         (c (make-code-vector l 0)))
    (do ((i 0 (+ i 1)))
        ((= i l)
         c)
      (code-vector-set! c i (vector-ref v i)))))
      
; the code part of an entry can be #f if it is equal to its previous entry      
(define (get-code backtrace index)
  (let loop ((index index))
    (cond
      ((< index 0)
       #f)
      ((not (car (vector-ref backtrace index)))
       (loop (- index 1)))
      (else
       (car (vector-ref backtrace index))))))

(define (vector-eq? v1 v2)
  (and (= (vector-length v1) (vector-length v2))
    (let loop ((i 0))
      (cond ((= i (vector-length v1))
             #t)
            ((eq? (vector-ref v1 i) (vector-ref v2 i))
             (loop (+ i 1)))
            (else
             #f)))))
             
(define make-code-table
  (make-table-maker
    vector-eq?
    (lambda (v) 1))) ; inefficient but valid hasher

(define make-call-table
  (make-table-maker
    (lambda (c1 c2)
      (and (eq? (car    c1) (car    c2))   ; call type
           (eq? (cadr   c1) (cadr   c2))   ; caller
           (eq? (caddr  c1) (caddr  c2)) ; callee
           (eq? (cadddr c1) (cadddr c2)))) ; caller pc
    (lambda (c) 1)))

(define (call-instruction? opcode)
  (memq (enumerand->name opcode op)
    '(call tail-call big-call known-tail-call known-call big-known-call apply closed-apply with-continuation call-template
      return values closed-values)))